home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume24 / gnucalc / part09 < prev    next >
Encoding:
Text File  |  1991-10-29  |  55.2 KB  |  1,829 lines
  1. Newsgroups: comp.sources.misc
  2. From: daveg@synaptics.com (David Gillespie)
  3. Subject:  v24i057:  gnucalc - GNU Emacs Calculator, v2.00, Part09/56
  4. Message-ID: <1991Oct29.225947.20060@sparky.imd.sterling.com>
  5. X-Md4-Signature: 88c6cc81bcf6453dc52b9e2f55c8f80b
  6. Date: Tue, 29 Oct 1991 22:59:47 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: daveg@synaptics.com (David Gillespie)
  10. Posting-number: Volume 24, Issue 57
  11. Archive-name: gnucalc/part09
  12. Environment: Emacs
  13. Supersedes: gmcalc: Volume 13, Issue 27-45
  14.  
  15. ---- Cut Here and unpack ----
  16. #!/bin/sh
  17. # this is Part.09 (part 9 of a multipart archive)
  18. # do not concatenate these parts, unpack them in order with /bin/sh
  19. # file calc-arith.el continued
  20. #
  21. if test ! -r _shar_seq_.tmp; then
  22.     echo 'Please unpack part 1 first!'
  23.     exit 1
  24. fi
  25. (read Scheck
  26.  if test "$Scheck" != 9; then
  27.     echo Please unpack part "$Scheck" next!
  28.     exit 1
  29.  else
  30.     exit 0
  31.  fi
  32. ) < _shar_seq_.tmp || exit 1
  33. if test ! -f _shar_wnt_.tmp; then
  34.     echo 'x - still skipping calc-arith.el'
  35. else
  36. echo 'x - continuing file calc-arith.el'
  37. sed 's/^X//' << 'SHAR_EOF' >> 'calc-arith.el' &&
  38. )
  39. X
  40. ;;; Fast function to multiply floating-point numbers.
  41. (defun math-mul-float (a b)   ; [F F F]
  42. X  (math-make-float (math-mul (nth 1 a) (nth 1 b))
  43. X           (+ (nth 2 a) (nth 2 b)))
  44. )
  45. X
  46. (defun math-sqr-float (a)   ; [F F]
  47. X  (math-make-float (math-mul (nth 1 a) (nth 1 a))
  48. X           (+ (nth 2 a) (nth 2 a)))
  49. )
  50. X
  51. (defun math-intv-constp (a &optional finite)
  52. X  (and (or (Math-anglep (nth 2 a))
  53. X       (and (equal (nth 2 a) '(neg (var inf var-inf)))
  54. X        (or (not finite)
  55. X            (memq (nth 1 a) '(0 1)))))
  56. X       (or (Math-anglep (nth 3 a))
  57. X       (and (equal (nth 3 a) '(var inf var-inf))
  58. X        (or (not finite)
  59. X            (memq (nth 1 a) '(0 2))))))
  60. )
  61. X
  62. (defun math-mul-zero (a b)
  63. X  (if (math-known-matrixp b)
  64. X      (if (math-vectorp b)
  65. X      (math-map-vec-2 'math-mul a b)
  66. X    (math-mimic-ident 0 b))
  67. X    (if (math-infinitep b)
  68. X    '(var nan var-nan)
  69. X      (let ((aa nil) (bb nil))
  70. X    (if (and (eq (car-safe b) 'intv)
  71. X         (progn
  72. X           (and (equal (nth 2 b) '(neg (var inf var-inf)))
  73. X            (memq (nth 1 b) '(2 3))
  74. X            (setq aa (nth 2 b)))
  75. X           (and (equal (nth 3 b) '(var inf var-inf))
  76. X            (memq (nth 1 b) '(1 3))
  77. X            (setq bb (nth 3 b)))
  78. X           (or aa bb)))
  79. X        (if (or (math-posp a)
  80. X            (and (math-zerop a)
  81. X             (or (memq calc-infinite-mode '(-1 1))
  82. X                 (setq aa '(neg (var inf var-inf))
  83. X                   bb '(var inf var-inf)))))
  84. X        (list 'intv 3 (or aa 0) (or bb 0))
  85. X          (if (math-negp a)
  86. X          (math-neg (list 'intv 3 (or aa 0) (or bb 0)))
  87. X        '(var nan var-nan)))
  88. X      (if (or (math-floatp a) (math-floatp b)) '(float 0 0) 0)))))
  89. )
  90. X
  91. X
  92. (defun math-mul-symb-fancy (a b)
  93. X  (or (and math-simplify-only
  94. X       (not (equal a math-simplify-only))
  95. X       (list '* a b))
  96. X      (and (Math-equal-int a 1)
  97. X       b)
  98. X      (and (Math-equal-int a -1)
  99. X       (math-neg b))
  100. X      (and (or (and (Math-vectorp a) (math-known-scalarp b))
  101. X           (and (Math-vectorp b) (math-known-scalarp a)))
  102. X       (math-map-vec-2 'math-mul a b))
  103. X      (and (Math-objectp b)
  104. X       (math-mul b a))
  105. X      (and (eq (car-safe a) 'neg)
  106. X       (math-neg (math-mul (nth 1 a) b)))
  107. X      (and (eq (car-safe b) 'neg)
  108. X       (math-neg (math-mul a (nth 1 b))))
  109. X      (and (eq (car-safe a) '*)
  110. X       (math-mul (nth 1 a)
  111. X             (math-mul (nth 2 a) b)))
  112. X      (and (eq (car-safe a) '^)
  113. X       (Math-looks-negp (nth 2 a))
  114. X       (not (and (eq (car-safe b) '^) (Math-looks-negp (nth 2 b))))
  115. X       (math-known-scalarp b t)
  116. X       (math-div b (math-normalize
  117. X            (list '^ (nth 1 a) (math-neg (nth 2 a))))))
  118. X      (and (eq (car-safe b) '^)
  119. X       (Math-looks-negp (nth 2 b))
  120. X       (not (and (eq (car-safe a) '^) (Math-looks-negp (nth 2 a))))
  121. X       (math-div a (math-normalize
  122. X            (list '^ (nth 1 b) (math-neg (nth 2 b))))))
  123. X      (and (eq (car-safe a) '/)
  124. X       (or (math-known-scalarp a t) (math-known-scalarp b t))
  125. X       (let ((temp (math-combine-prod (nth 2 a) b t nil t)))
  126. X         (if temp
  127. X         (math-mul (nth 1 a) temp)
  128. X           (math-div (math-mul (nth 1 a) b) (nth 2 a)))))
  129. X      (and (eq (car-safe b) '/)
  130. X       (math-div (math-mul a (nth 1 b)) (nth 2 b)))
  131. X      (and (eq (car-safe b) '+)
  132. X       (Math-numberp a)
  133. X       (or (Math-numberp (nth 1 b))
  134. X           (Math-numberp (nth 2 b)))
  135. X       (math-add (math-mul a (nth 1 b))
  136. X             (math-mul a (nth 2 b))))
  137. X      (and (eq (car-safe b) '-)
  138. X       (Math-numberp a)
  139. X       (or (Math-numberp (nth 1 b))
  140. X           (Math-numberp (nth 2 b)))
  141. X       (math-sub (math-mul a (nth 1 b))
  142. X             (math-mul a (nth 2 b))))
  143. X      (and (eq (car-safe b) '*)
  144. X       (Math-numberp (nth 1 b))
  145. X       (not (Math-numberp a))
  146. X       (math-mul (nth 1 b) (math-mul a (nth 2 b))))
  147. X      (and (eq (car-safe a) 'calcFunc-idn)
  148. X       (= (length a) 2)
  149. X       (or (and (eq (car-safe b) 'calcFunc-idn)
  150. X            (= (length b) 2)
  151. X            (list 'calcFunc-idn (math-mul (nth 1 a) (nth 1 b))))
  152. X           (and (math-known-scalarp b)
  153. X            (list 'calcFunc-idn (math-mul (nth 1 a) b)))
  154. X           (and (math-known-matrixp b)
  155. X            (math-mul (nth 1 a) b))))
  156. X      (and (eq (car-safe b) 'calcFunc-idn)
  157. X       (= (length b) 2)
  158. X       (or (and (math-known-scalarp a)
  159. X            (list 'calcFunc-idn (math-mul a (nth 1 b))))
  160. X           (and (math-known-matrixp a)
  161. X            (math-mul a (nth 1 b)))))
  162. X      (and (math-looks-negp b)
  163. X       (math-mul (math-neg a) (math-neg b)))
  164. X      (and (eq (car-safe b) '-)
  165. X       (math-looks-negp a)
  166. X       (math-mul (math-neg a) (math-neg b)))
  167. X      (cond
  168. X       ((eq (car-safe b) '*)
  169. X    (let ((temp (math-combine-prod a (nth 1 b) nil nil t)))
  170. X      (and temp
  171. X           (math-mul temp (nth 2 b)))))
  172. X       (t
  173. X    (math-combine-prod a b nil nil nil)))
  174. X      (and (equal a '(var nan var-nan))
  175. X       a)
  176. X      (and (equal b '(var nan var-nan))
  177. X       b)
  178. X      (and (equal a '(var uinf var-uinf))
  179. X       a)
  180. X      (and (equal b '(var uinf var-uinf))
  181. X       b)
  182. X      (and (equal b '(var inf var-inf))
  183. X       (let ((s1 (math-possible-signs a)))
  184. X         (cond ((eq s1 4)
  185. X            b)
  186. X           ((eq s1 6)
  187. X            '(intv 3 0 (var inf var-inf)))
  188. X           ((eq s1 1)
  189. X            (math-neg b))
  190. X           ((eq s1 3)
  191. X            '(intv 3 (neg (var inf var-inf)) 0))
  192. X           ((and (eq (car a) 'intv) (math-intv-constp a))
  193. X            '(intv 3 (neg (var inf var-inf)) (var inf var-inf)))
  194. X           ((and (eq (car a) 'cplx)
  195. X             (math-zerop (nth 1 a)))
  196. X            (list '* (list 'cplx 0 (calcFunc-sign (nth 2 a))) b))
  197. X           ((eq (car a) 'polar)
  198. X            (list '* (list 'polar 1 (nth 2 a)) b)))))
  199. X      (and (equal a '(var inf var-inf))
  200. X       (math-mul b a))
  201. X      (list '* a b))
  202. )
  203. X
  204. X
  205. (defun calcFunc-div (a &rest rest)
  206. X  (while rest
  207. X    (setq a (list '/ a (car rest))
  208. X      rest (cdr rest)))
  209. X  (math-normalize a)
  210. )
  211. X
  212. (defun math-div-objects-fancy (a b)
  213. X  (cond ((and (Math-numberp a) (Math-numberp b))
  214. X     (math-normalize
  215. X      (cond ((math-want-polar a b)
  216. X         (let ((a (math-polar a))
  217. X               (b (math-polar b)))
  218. X           (list 'polar
  219. X             (math-div (nth 1 a) (nth 1 b))
  220. X             (math-fix-circular (math-sub (nth 2 a)
  221. X                              (nth 2 b))))))
  222. X        ((Math-realp b)
  223. X         (setq a (math-complex a))
  224. X         (list 'cplx (math-div (nth 1 a) b)
  225. X               (math-div (nth 2 a) b)))
  226. X        (t
  227. X         (setq a (math-complex a)
  228. X               b (math-complex b))
  229. X         (math-div
  230. X          (list 'cplx
  231. X            (math-add (math-mul (nth 1 a) (nth 1 b))
  232. X                  (math-mul (nth 2 a) (nth 2 b)))
  233. X            (math-sub (math-mul (nth 2 a) (nth 1 b))
  234. X                  (math-mul (nth 1 a) (nth 2 b))))
  235. X          (math-add (math-sqr (nth 1 b))
  236. X                (math-sqr (nth 2 b))))))))
  237. X    ((math-matrixp b)
  238. X     (if (math-square-matrixp b)
  239. X         (let ((n1 (length b)))
  240. X           (if (Math-vectorp a)
  241. X           (if (math-matrixp a)
  242. X               (if (= (length a) n1)
  243. X               (math-lud-solve (math-matrix-lud b) a b)
  244. X             (if (= (length (nth 1 a)) n1)
  245. X                 (math-transpose
  246. X                  (math-lud-solve (math-matrix-lud
  247. X                           (math-transpose b))
  248. X                          (math-transpose a) b))
  249. X               (math-dimension-error)))
  250. X             (if (= (length a) n1)
  251. X             (math-mat-col (math-lud-solve (math-matrix-lud b)
  252. X                               (math-col-matrix a) b)
  253. X                       1)
  254. X               (math-dimension-error)))
  255. X         (if (Math-equal-int a 1)
  256. X             (calcFunc-inv b)
  257. X           (math-mul a (calcFunc-inv b)))))
  258. X       (math-reject-arg b 'square-matrixp)))
  259. X    ((and (Math-vectorp a) (Math-objectp b))
  260. X     (math-map-vec-2 'math-div a b))
  261. X    ((eq (car-safe a) 'sdev)
  262. X     (if (eq (car-safe b) 'sdev)
  263. X         (let ((x (math-div (nth 1 a) (nth 1 b))))
  264. X           (math-make-sdev x
  265. X                   (math-div (math-hypot (nth 2 a)
  266. X                             (math-mul (nth 2 b) x))
  267. X                     (nth 1 b))))
  268. X       (if (or (Math-scalarp b)
  269. X           (not (Math-objvecp b)))
  270. X           (math-make-sdev (math-div (nth 1 a) b) (math-div (nth 2 a) b))
  271. X         (math-reject-arg 'realp b))))
  272. X    ((and (eq (car-safe b) 'sdev)
  273. X          (or (Math-scalarp a)
  274. X          (not (Math-objvecp a))))
  275. X     (let ((x (math-div a (nth 1 b))))
  276. X       (math-make-sdev x
  277. X               (math-div (math-mul (nth 2 b) x) (nth 1 b)))))
  278. X    ((and (eq (car-safe a) 'intv) (Math-anglep b))
  279. X     (if (Math-negp b)
  280. X         (math-neg (math-div a (math-neg b)))
  281. X       (math-make-intv (nth 1 a)
  282. X               (math-div (nth 2 a) b)
  283. X               (math-div (nth 3 a) b))))
  284. X    ((and (eq (car-safe b) 'intv) (Math-anglep a))
  285. X     (if (or (Math-posp (nth 2 b))
  286. X         (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1))
  287. X                         calc-infinite-mode)))
  288. X         (if (Math-negp a)
  289. X         (math-neg (math-div (math-neg a) b))
  290. X           (let ((calc-infinite-mode 1))
  291. X         (math-make-intv (aref [0 2 1 3] (nth 1 b))
  292. X                 (math-div a (nth 3 b))
  293. X                 (math-div a (nth 2 b)))))
  294. X       (if (or (Math-negp (nth 3 b))
  295. X           (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2))
  296. X                           calc-infinite-mode)))
  297. X           (math-neg (math-div a (math-neg b)))
  298. X         (if calc-infinite-mode
  299. X         '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
  300. X           (math-reject-arg b "*Division by zero")))))
  301. X    ((and (eq (car-safe a) 'intv) (math-intv-constp a)
  302. X          (eq (car-safe b) 'intv) (math-intv-constp b))
  303. X     (if (or (Math-posp (nth 2 b))
  304. X         (and (Math-zerop (nth 2 b)) (or (memq (nth 1 b) '(0 1))
  305. X                         calc-infinite-mode)))
  306. X         (let* ((calc-infinite-mode 1)
  307. X            (lo (math-div a (nth 2 b)))
  308. X            (hi (math-div a (nth 3 b))))
  309. X           (or (eq (car-safe lo) 'intv)
  310. X           (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0)
  311. X                  lo lo)))
  312. X           (or (eq (car-safe hi) 'intv)
  313. X           (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0)
  314. X                  hi hi)))
  315. X           (math-combine-intervals
  316. X        (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
  317. X                    (and (math-infinitep (nth 2 lo))
  318. X                     (not (math-zerop (nth 2 b)))))
  319. X                (memq (nth 1 lo) '(2 3)))
  320. X        (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
  321. X                    (and (math-infinitep (nth 3 lo))
  322. X                     (not (math-zerop (nth 2 b)))))
  323. X                (memq (nth 1 lo) '(1 3)))
  324. X        (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
  325. X                    (and (math-infinitep (nth 2 hi))
  326. X                     (not (math-zerop (nth 3 b)))))
  327. X                (memq (nth 1 hi) '(2 3)))
  328. X        (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
  329. X                    (and (math-infinitep (nth 3 hi))
  330. X                     (not (math-zerop (nth 3 b)))))
  331. X                (memq (nth 1 hi) '(1 3)))))
  332. X       (if (or (Math-negp (nth 3 b))
  333. X           (and (Math-zerop (nth 3 b)) (or (memq (nth 1 b) '(0 2))
  334. X                           calc-infinite-mode)))
  335. X           (math-neg (math-div a (math-neg b)))
  336. X         (if calc-infinite-mode
  337. X         '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
  338. X           (math-reject-arg b "*Division by zero")))))
  339. X    ((and (eq (car-safe a) 'mod)
  340. X          (eq (car-safe b) 'mod)
  341. X          (equal (nth 2 a) (nth 2 b)))
  342. X     (math-make-mod (math-div-mod (nth 1 a) (nth 1 b) (nth 2 a))
  343. X            (nth 2 a)))
  344. X    ((and (eq (car-safe a) 'mod)
  345. X          (Math-anglep b))
  346. X     (math-make-mod (math-div-mod (nth 1 a) b (nth 2 a)) (nth 2 a)))
  347. X    ((and (eq (car-safe b) 'mod)
  348. X          (Math-anglep a))
  349. X     (math-make-mod (math-div-mod a (nth 1 b) (nth 2 b)) (nth 2 b)))
  350. X    ((eq (car-safe a) 'hms)
  351. X     (if (eq (car-safe b) 'hms)
  352. X         (math-with-extra-prec 1
  353. X           (math-div (math-from-hms a 'deg)
  354. X             (math-from-hms b 'deg)))
  355. X       (math-with-extra-prec 2
  356. X         (math-to-hms (math-div (math-from-hms a 'deg) b) 'deg))))
  357. X    (t (calc-record-why "*Incompatible arguments for /" a b)))
  358. )
  359. X
  360. (defun math-div-by-zero (a b)
  361. X  (if (math-infinitep a)
  362. X      (if (or (equal a '(var nan var-nan))
  363. X          (equal b '(var uinf var-uinf))
  364. X          (memq calc-infinite-mode '(-1 1)))
  365. X      a
  366. X    '(var uinf var-uinf))
  367. X    (if calc-infinite-mode
  368. X    (if (math-zerop a)
  369. X        '(var nan var-nan)
  370. X      (if (eq calc-infinite-mode 1)
  371. X          (math-mul a '(var inf var-inf))
  372. X        (if (eq calc-infinite-mode -1)
  373. X        (math-mul a '(neg (var inf var-inf)))
  374. X          (if (eq (car-safe a) 'intv)
  375. X          '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
  376. X        '(var uinf var-uinf)))))
  377. X      (math-reject-arg a "*Division by zero")))
  378. )
  379. X
  380. (defun math-div-zero (a b)
  381. X  (if (math-known-matrixp b)
  382. X      (if (math-vectorp b)
  383. X      (math-map-vec-2 'math-div a b)
  384. X    (math-mimic-ident 0 b))
  385. X    (if (equal b '(var nan var-nan))
  386. X    b
  387. X      (if (and (eq (car-safe b) 'intv) (math-intv-constp b)
  388. X           (not (math-posp b)) (not (math-negp b)))
  389. X      (if calc-infinite-mode
  390. X          (list 'intv 3
  391. X            (if (and (math-zerop (nth 2 b))
  392. X                 (memq calc-infinite-mode '(1 -1)))
  393. X            (nth 2 b) '(neg (var inf var-inf)))
  394. X            (if (and (math-zerop (nth 3 b))
  395. X                 (memq calc-infinite-mode '(1 -1)))
  396. X            (nth 3 b) '(var inf var-inf)))
  397. X        (math-reject-arg b "*Division by zero"))
  398. X    a)))
  399. )
  400. X
  401. (defun math-div-symb-fancy (a b)
  402. X  (or (and math-simplify-only
  403. X       (not (equal a math-simplify-only))
  404. X       (list '/ a b))
  405. X      (and (Math-equal-int b 1) a)
  406. X      (and (Math-equal-int b -1) (math-neg a))
  407. X      (and (Math-vectorp a) (math-known-scalarp b)
  408. X       (math-map-vec-2 'math-div a b))
  409. X      (and (eq (car-safe b) '^)
  410. X       (or (Math-looks-negp (nth 2 b)) (Math-equal-int a 1))
  411. X       (math-mul a (math-normalize
  412. X            (list '^ (nth 1 b) (math-neg (nth 2 b))))))
  413. X      (and (eq (car-safe a) 'neg)
  414. X       (math-neg (math-div (nth 1 a) b)))
  415. X      (and (eq (car-safe b) 'neg)
  416. X       (math-neg (math-div a (nth 1 b))))
  417. X      (and (eq (car-safe a) '/)
  418. X       (math-div (nth 1 a) (math-mul (nth 2 a) b)))
  419. X      (and (eq (car-safe b) '/)
  420. X       (or (math-known-scalarp (nth 1 b) t)
  421. X           (math-known-scalarp (nth 2 b) t))
  422. X       (math-div (math-mul a (nth 2 b)) (nth 1 b)))
  423. X      (and (eq (car-safe b) 'frac)
  424. X       (math-mul (math-make-frac (nth 2 b) (nth 1 b)) a))
  425. X      (and (eq (car-safe a) '+)
  426. X       (or (Math-numberp (nth 1 a))
  427. X           (Math-numberp (nth 2 a)))
  428. X       (Math-numberp b)
  429. X       (math-add (math-div (nth 1 a) b)
  430. X             (math-div (nth 2 a) b)))
  431. X      (and (eq (car-safe a) '-)
  432. X       (or (Math-numberp (nth 1 a))
  433. X           (Math-numberp (nth 2 a)))
  434. X       (Math-numberp b)
  435. X       (math-sub (math-div (nth 1 a) b)
  436. X             (math-div (nth 2 a) b)))
  437. X      (and (or (eq (car-safe a) '-)
  438. X           (math-looks-negp a))
  439. X       (math-looks-negp b)
  440. X       (math-div (math-neg a) (math-neg b)))
  441. X      (and (eq (car-safe b) '-)
  442. X       (math-looks-negp a)
  443. X       (math-div (math-neg a) (math-neg b)))
  444. X      (and (eq (car-safe a) 'calcFunc-idn)
  445. X       (= (length a) 2)
  446. X       (or (and (eq (car-safe b) 'calcFunc-idn)
  447. X            (= (length b) 2)
  448. X            (list 'calcFunc-idn (math-div (nth 1 a) (nth 1 b))))
  449. X           (and (math-known-scalarp b)
  450. X            (list 'calcFunc-idn (math-div (nth 1 a) b)))
  451. X           (and (math-known-matrixp b)
  452. X            (math-div (nth 1 a) b))))
  453. X      (and (eq (car-safe b) 'calcFunc-idn)
  454. X       (= (length b) 2)
  455. X       (or (and (math-known-scalarp a)
  456. X            (list 'calcFunc-idn (math-div a (nth 1 b))))
  457. X           (and (math-known-matrixp a)
  458. X            (math-div a (nth 1 b)))))
  459. X      (if (and calc-matrix-mode
  460. X           (or (math-known-matrixp a) (math-known-matrixp b)))
  461. X      (math-combine-prod a b nil t nil)
  462. X    (if (eq (car-safe a) '*)
  463. X        (if (eq (car-safe b) '*)
  464. X        (let ((c (math-combine-prod (nth 1 a) (nth 1 b) nil t t)))
  465. X          (and c
  466. X               (math-div (math-mul c (nth 2 a)) (nth 2 b))))
  467. X          (let ((c (math-combine-prod (nth 1 a) b nil t t)))
  468. X        (and c
  469. X             (math-mul c (nth 2 a)))))
  470. X      (if (eq (car-safe b) '*)
  471. X          (let ((c (math-combine-prod a (nth 1 b) nil t t)))
  472. X        (and c
  473. X             (math-div c (nth 2 b))))
  474. X        (math-combine-prod a b nil t nil))))
  475. X      (and (math-infinitep a)
  476. X       (if (math-infinitep b)
  477. X           '(var nan var-nan)
  478. X         (if (or (equal a '(var nan var-nan))
  479. X             (equal a '(var uinf var-uinf)))
  480. X         a
  481. X           (if (equal a '(var inf var-inf))
  482. X           (if (or (math-posp b)
  483. X               (and (eq (car-safe b) 'intv)
  484. X                (math-zerop (nth 2 b))))
  485. X               (if (and (eq (car-safe b) 'intv)
  486. X                (not (math-intv-constp b t)))
  487. X               '(intv 3 0 (var inf var-inf))
  488. X             a)
  489. X             (if (or (math-negp b)
  490. X                 (and (eq (car-safe b) 'intv)
  491. X                  (math-zerop (nth 3 b))))
  492. X             (if (and (eq (car-safe b) 'intv)
  493. X                  (not (math-intv-constp b t)))
  494. X                 '(intv 3 (neg (var inf var-inf)) 0)
  495. X               (math-neg a))
  496. X               (if (and (eq (car-safe b) 'intv)
  497. X                (math-negp (nth 2 b)) (math-posp (nth 3 b)))
  498. X               '(intv 3 (neg (var inf var-inf))
  499. X                  (var inf var-inf)))))))))
  500. X      (and (math-infinitep b)
  501. X       (if (equal b '(var nan var-nan))
  502. X           b
  503. X         (let ((calc-infinite-mode 1))
  504. X           (math-mul-zero b a))))
  505. X      (list '/ a b))
  506. )
  507. X
  508. X
  509. (defun calcFunc-mod (a b)
  510. X  (math-normalize (list '% a b))
  511. )
  512. X
  513. (defun math-mod-fancy (a b)
  514. X  (cond ((equal b '(var inf var-inf))
  515. X     (if (or (math-posp a) (math-zerop a))
  516. X         a
  517. X       (if (math-negp a)
  518. X           b
  519. X         (if (eq (car-safe a) 'intv)
  520. X         (if (math-negp (nth 2 a))
  521. X             '(intv 3 0 (var inf var-inf))
  522. X           a)
  523. X           (list '% a b)))))
  524. X    ((and (eq (car-safe a) 'mod) (Math-realp b) (math-posp b))
  525. X     (math-make-mod (nth 1 a) b))
  526. X    ((and (eq (car-safe a) 'intv) (math-intv-constp a t) (math-posp b))
  527. X     (math-mod-intv a b))
  528. X    (t
  529. X     (if (Math-anglep a)
  530. X         (calc-record-why 'anglep b)
  531. X       (calc-record-why 'anglep a))
  532. X     (list '% a b)))
  533. )
  534. X
  535. X
  536. (defun calcFunc-pow (a b)
  537. X  (math-normalize (list '^ a b))
  538. )
  539. X
  540. (defun math-pow-of-zero (a b)
  541. X  (if (Math-zerop b)
  542. X      (if calc-infinite-mode
  543. X      '(var nan var-nan)
  544. X    (math-reject-arg (list '^ a b) "*Indeterminate form"))
  545. X    (if (math-floatp b) (setq a (math-float a)))
  546. X    (if (math-posp b)
  547. X    a
  548. X      (if (math-negp b)
  549. X      (math-div 1 a)
  550. X    (if (math-infinitep b)
  551. X        '(var nan var-nan)
  552. X      (if (and (eq (car b) 'intv) (math-intv-constp b)
  553. X           calc-infinite-mode)
  554. X          '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
  555. X        (if (math-objectp b)
  556. X        (list '^ a b)
  557. X          a))))))
  558. )
  559. X
  560. (defun math-pow-zero (a b)
  561. X  (if (eq (car-safe a) 'mod)
  562. X      (math-make-mod 1 (nth 2 a))
  563. X    (if (math-known-matrixp a)
  564. X    (math-mimic-ident 1 a)
  565. X      (if (math-infinitep a)
  566. X      '(var nan var-nan)
  567. X    (if (and (eq (car a) 'intv) (math-intv-constp a)
  568. X         (or (and (not (math-posp a)) (not (math-negp a)))
  569. X             (not (math-intv-constp a t))))
  570. X        '(intv 3 (neg (var inf var-inf)) (var inf var-inf))
  571. X      (if (or (math-floatp a) (math-floatp b))
  572. X          '(float 1 0) 1)))))
  573. )
  574. X
  575. (defun math-pow-fancy (a b)
  576. X  (cond ((and (Math-numberp a) (Math-numberp b))
  577. X     (or (if (memq (math-quarter-integer b) '(1 2 3))
  578. X         (let ((sqrt (math-sqrt (if (math-floatp b)
  579. X                        (math-float a) a))))
  580. X           (and (Math-numberp sqrt)
  581. X            (math-pow sqrt (math-mul 2 b))))
  582. X           (and (eq (car b) 'frac)
  583. X            (integerp (nth 2 b))
  584. X            (<= (nth 2 b) 10)
  585. X            (let ((root (math-nth-root a (nth 2 b))))
  586. X              (and root (math-ipow root (nth 1 b))))))
  587. X         (and (or (eq a 10) (equal a '(float 1 1)))
  588. X          (math-num-integerp b)
  589. X          (calcFunc-scf '(float 1 0) b))
  590. X         (and calc-symbolic-mode
  591. X          (list '^ a b))
  592. X         (math-with-extra-prec 2
  593. X           (math-exp-raw
  594. X        (math-float (math-mul b (math-ln-raw (math-float a))))))))
  595. X    ((or (not (Math-objvecp a))
  596. X         (not (Math-objectp b)))
  597. X     (let (temp)
  598. X       (cond ((and math-simplify-only
  599. X               (not (equal a math-simplify-only)))
  600. X          (list '^ a b))
  601. X         ((and (eq (car-safe a) '*)
  602. X               (or (math-known-num-integerp b)
  603. X               (math-known-nonnegp (nth 1 a))
  604. X               (math-known-nonnegp (nth 2 a))))
  605. X          (math-mul (math-pow (nth 1 a) b)
  606. X                (math-pow (nth 2 a) b)))
  607. X         ((and (eq (car-safe a) '/)
  608. X               (or (math-known-num-integerp b)
  609. X               (math-known-nonnegp (nth 2 a))))
  610. X          (math-div (math-pow (nth 1 a) b)
  611. X                (math-pow (nth 2 a) b)))
  612. X         ((and (eq (car-safe a) '/)
  613. X               (math-known-nonnegp (nth 1 a))
  614. X               (not (math-equal-int (nth 1 a) 1)))
  615. X          (math-mul (math-pow (nth 1 a) b)
  616. X                (math-pow (math-div 1 (nth 2 a)) b)))
  617. X         ((and (eq (car-safe a) '^)
  618. X               (or (math-known-num-integerp b)
  619. X               (math-known-nonnegp (nth 1 a))))
  620. X          (math-pow (nth 1 a) (math-mul (nth 2 a) b)))
  621. X         ((and (eq (car-safe a) 'calcFunc-sqrt)
  622. X               (or (math-known-num-integerp b)
  623. X               (math-known-nonnegp (nth 1 a))))
  624. X          (math-pow (nth 1 a) (math-div b 2)))
  625. X         ((and (eq (car-safe a) '^)
  626. X               (math-known-evenp (nth 2 a))
  627. X               (memq (math-quarter-integer b) '(1 2 3))
  628. X               (math-known-realp (nth 1 a)))
  629. X          (math-abs (math-pow (nth 1 a) (math-mul (nth 2 a) b))))
  630. X         ((and (math-looks-negp a)
  631. X               (math-known-integerp b)
  632. X               (setq temp (or (and (math-known-evenp b)
  633. X                       (math-pow (math-neg a) b))
  634. X                      (and (math-known-oddp b)
  635. X                       (math-neg (math-pow (math-neg a)
  636. X                                   b))))))
  637. X          temp)
  638. X         ((and (eq (car-safe a) 'calcFunc-abs)
  639. X               (math-known-realp (nth 1 a))
  640. X               (math-known-evenp b))
  641. X          (math-pow (nth 1 a) b))
  642. X         ((math-infinitep a)
  643. X          (cond ((equal a '(var nan var-nan))
  644. X             a)
  645. X            ((eq (car a) 'neg)
  646. X             (math-mul (math-pow -1 b) (math-pow (nth 1 a) b)))
  647. X            ((math-posp b)
  648. X             a)
  649. X            ((math-negp b)
  650. X             (if (math-floatp b) '(float 0 0) 0))
  651. X            ((and (eq (car-safe b) 'intv)
  652. X                  (math-intv-constp b))
  653. X             '(intv 3 0 (var inf var-inf)))
  654. X            (t
  655. X             '(var nan var-nan))))
  656. X         ((math-infinitep b)
  657. X          (let (scale)
  658. X            (cond ((math-negp b)
  659. X               (math-pow (math-div 1 a) (math-neg b)))
  660. X              ((not (math-posp b))
  661. X               '(var nan var-nan))
  662. X              ((math-equal-int (setq scale (calcFunc-abssqr a)) 1)
  663. X               '(var nan var-nan))
  664. X              ((Math-lessp scale 1)
  665. X               (if (math-floatp a) '(float 0 0) 0))
  666. X              ((Math-lessp 1 a)
  667. X               b)
  668. X              ((Math-lessp a -1)
  669. X               '(var uinf var-uinf))
  670. X              ((and (eq (car a) 'intv)
  671. X                (math-intv-constp a))
  672. X               (if (Math-lessp -1 a)
  673. X                   (if (math-equal-int (nth 3 a) 1)
  674. X                   '(intv 3 0 1)
  675. X                 '(intv 3 0 (var inf var-inf)))
  676. X                 '(intv 3 (neg (var inf var-inf))
  677. X                    (var inf var-inf))))
  678. X              (t (list '^ a b)))))
  679. X         ((and (eq (car-safe a) 'calcFunc-idn)
  680. X               (= (length a) 2)
  681. X               (math-known-num-integerp b))
  682. X          (list 'calcFunc-idn (math-pow (nth 1 a) b)))
  683. X         (t (if (Math-objectp a)
  684. X            (calc-record-why 'objectp b)
  685. X              (calc-record-why 'objectp a))
  686. X            (list '^ a b)))))
  687. X    ((and (eq (car-safe a) 'sdev) (eq (car-safe b) 'sdev))
  688. X     (if (and (math-constp a) (math-constp b))
  689. X         (math-with-extra-prec 2
  690. X           (let* ((ln (math-ln-raw (math-float (nth 1 a))))
  691. X              (pow (math-exp-raw
  692. X                (math-float (math-mul (nth 1 b) ln)))))
  693. X         (math-make-sdev
  694. X          pow
  695. X          (math-mul
  696. X           pow
  697. X           (math-hypot (math-mul (nth 2 a)
  698. X                     (math-div (nth 1 b) (nth 1 a)))
  699. X                   (math-mul (nth 2 b) ln))))))
  700. X       (let ((pow (math-pow (nth 1 a) (nth 1 b))))
  701. X         (math-make-sdev
  702. X          pow
  703. X          (math-mul pow
  704. X            (math-hypot (math-mul (nth 2 a)
  705. X                          (math-div (nth 1 b) (nth 1 a)))
  706. X                    (math-mul (nth 2 b) (calcFunc-ln
  707. X                             (nth 1 a)))))))))
  708. X    ((and (eq (car-safe a) 'sdev) (Math-numberp b))
  709. X     (if (math-constp a)
  710. X         (math-with-extra-prec 2
  711. X           (let ((pow (math-pow (nth 1 a) (math-sub b 1))))
  712. X         (math-make-sdev (math-mul pow (nth 1 a))
  713. X                 (math-mul pow (math-mul (nth 2 a) b)))))
  714. X       (math-make-sdev (math-pow (nth 1 a) b)
  715. X               (math-mul (math-pow (nth 1 a) (math-add b -1))
  716. X                     (math-mul (nth 2 a) b)))))
  717. X    ((and (eq (car-safe b) 'sdev) (Math-numberp a))
  718. X     (math-with-extra-prec 2
  719. X       (let* ((ln (math-ln-raw (math-float a)))
  720. X          (pow (calcFunc-exp (math-mul (nth 1 b) ln))))
  721. X         (math-make-sdev pow (math-mul pow (math-mul (nth 2 b) ln))))))
  722. X    ((and (eq (car-safe a) 'intv) (math-intv-constp a)
  723. X          (Math-realp b)
  724. X          (or (Math-natnump b)
  725. X          (Math-posp (nth 2 a))
  726. X          (and (math-zerop (nth 2 a))
  727. X               (or (Math-posp b)
  728. X               (and (Math-integerp b) calc-infinite-mode)))
  729. X          (Math-negp (nth 3 a))
  730. X          (and (math-zerop (nth 3 a))
  731. X               (or (Math-posp b)
  732. X               (and (Math-integerp b) calc-infinite-mode)))))
  733. X     (if (math-evenp b)
  734. X         (setq a (math-abs a)))
  735. X     (let ((calc-infinite-mode (if (math-zerop (nth 3 a)) -1 1)))
  736. X       (math-sort-intv (nth 1 a)
  737. X               (math-pow (nth 2 a) b)
  738. X               (math-pow (nth 3 a) b))))
  739. X    ((and (eq (car-safe b) 'intv) (math-intv-constp b)
  740. X          (Math-realp a) (Math-posp a))
  741. X     (math-sort-intv (nth 1 b)
  742. X             (math-pow a (nth 2 b))
  743. X             (math-pow a (nth 3 b))))
  744. X    ((and (eq (car-safe a) 'intv) (math-intv-constp a)
  745. X          (eq (car-safe b) 'intv) (math-intv-constp b)
  746. X          (or (and (not (Math-negp (nth 2 a)))
  747. X               (not (Math-negp (nth 2 b))))
  748. X          (and (Math-posp (nth 2 a))
  749. X               (not (Math-posp (nth 3 b))))))
  750. X     (let ((lo (math-pow a (nth 2 b)))
  751. X           (hi (math-pow a (nth 3 b))))
  752. X       (or (eq (car-safe lo) 'intv)
  753. X           (setq lo (list 'intv (if (memq (nth 1 b) '(2 3)) 3 0) lo lo)))
  754. X       (or (eq (car-safe hi) 'intv)
  755. X           (setq hi (list 'intv (if (memq (nth 1 b) '(1 3)) 3 0) hi hi)))
  756. X       (math-combine-intervals
  757. X        (nth 2 lo) (and (or (memq (nth 1 b) '(2 3))
  758. X                (math-infinitep (nth 2 lo)))
  759. X                (memq (nth 1 lo) '(2 3)))
  760. X        (nth 3 lo) (and (or (memq (nth 1 b) '(2 3))
  761. X                (math-infinitep (nth 3 lo)))
  762. X                (memq (nth 1 lo) '(1 3)))
  763. X        (nth 2 hi) (and (or (memq (nth 1 b) '(1 3))
  764. X                (math-infinitep (nth 2 hi)))
  765. X                (memq (nth 1 hi) '(2 3)))
  766. X        (nth 3 hi) (and (or (memq (nth 1 b) '(1 3))
  767. X                (math-infinitep (nth 3 hi)))
  768. X                (memq (nth 1 hi) '(1 3))))))
  769. X    ((and (eq (car-safe a) 'mod) (eq (car-safe b) 'mod)
  770. X          (equal (nth 2 a) (nth 2 b)))
  771. X     (math-make-mod (math-pow-mod (nth 1 a) (nth 1 b) (nth 2 a))
  772. X            (nth 2 a)))
  773. X    ((and (eq (car-safe a) 'mod) (Math-anglep b))
  774. X     (math-make-mod (math-pow-mod (nth 1 a) b (nth 2 a)) (nth 2 a)))
  775. X    ((and (eq (car-safe b) 'mod) (Math-anglep a))
  776. X     (math-make-mod (math-pow-mod a (nth 1 b) (nth 2 b)) (nth 2 b)))
  777. X    ((not (Math-numberp a))
  778. X     (math-reject-arg a 'numberp))
  779. X    (t
  780. X     (math-reject-arg b 'numberp)))
  781. )
  782. X
  783. (defun math-quarter-integer (x)
  784. X  (if (Math-integerp x)
  785. X      0
  786. X    (if (math-negp x)
  787. X    (progn
  788. X      (setq x (math-quarter-integer (math-neg x)))
  789. X      (and x (- 4 x)))
  790. X      (if (eq (car x) 'frac)
  791. X      (if (eq (nth 2 x) 2)
  792. X          2
  793. X        (and (eq (nth 2 x) 4)
  794. X         (progn
  795. X           (setq x (nth 1 x))
  796. X           (% (if (consp x) (nth 1 x) x) 4))))
  797. X    (if (eq (car x) 'float)
  798. X        (if (>= (nth 2 x) 0)
  799. X        0
  800. X          (if (= (nth 2 x) -1)
  801. X          (progn
  802. X            (setq x (nth 1 x))
  803. X            (and (= (% (if (consp x) (nth 1 x) x) 10) 5) 2))
  804. X        (if (= (nth 2 x) -2)
  805. X            (progn
  806. X              (setq x (nth 1 x)
  807. X                x (% (if (consp x) (nth 1 x) x) 100))
  808. X              (if (= x 25) 1
  809. X            (if (= x 75) 3))))))))))
  810. )
  811. X
  812. ;;; This assumes A < M and M > 0.
  813. (defun math-pow-mod (a b m)   ; [R R R R]
  814. X  (if (and (Math-integerp a) (Math-integerp b) (Math-integerp m))
  815. X      (if (Math-negp b)
  816. X      (math-div-mod 1 (math-pow-mod a (Math-integer-neg b) m) m)
  817. X    (if (eq m 1)
  818. X        0
  819. X      (math-pow-mod-step a b m)))
  820. X    (math-mod (math-pow a b) m))
  821. )
  822. X
  823. (defun math-pow-mod-step (a n m)   ; [I I I I]
  824. X  (math-working "pow" a)
  825. X  (let ((val (cond
  826. X          ((eq n 0) 1)
  827. X          ((eq n 1) a)
  828. X          (t
  829. X           (let ((rest (math-pow-mod-step
  830. X                (math-imod (math-mul a a) m)
  831. X                (math-div2 n)
  832. X                m)))
  833. X         (if (math-evenp n)
  834. X             rest
  835. X           (math-mod (math-mul a rest) m)))))))
  836. X    (math-working "pow" val)
  837. X    val)
  838. )
  839. X
  840. X
  841. ;;; Compute the minimum of two real numbers.  [R R R] [Public]
  842. (defun math-min (a b)
  843. X  (if (and (consp a) (eq (car a) 'intv))
  844. X      (if (and (consp b) (eq (car b) 'intv))
  845. X      (let ((lo (nth 2 a))
  846. X        (lom (memq (nth 1 a) '(2 3)))
  847. X        (hi (nth 3 a))
  848. X        (him (memq (nth 1 a) '(1 3)))
  849. X        res)
  850. X        (if (= (setq res (math-compare (nth 2 b) lo)) -1)
  851. X        (setq lo (nth 2 b) lom (memq (nth 1 b) '(2 3)))
  852. X          (if (= res 0)
  853. X          (setq lom (or lom (memq (nth 1 b) '(2 3))))))
  854. X        (if (= (setq res (math-compare (nth 3 b) hi)) -1)
  855. X        (setq hi (nth 3 b) him (memq (nth 1 b) '(1 3)))
  856. X          (if (= res 0)
  857. X          (setq him (or him (memq (nth 1 b) '(1 3))))))
  858. X        (math-make-intv (+ (if lom 2 0) (if him 1 0)) lo hi))
  859. X    (math-min a (list 'intv 3 b b)))
  860. X    (if (and (consp b) (eq (car b) 'intv))
  861. X    (math-min (list 'intv 3 a a) b)
  862. X      (let ((res (math-compare a b)))
  863. X    (if (= res 1)
  864. X        b
  865. X      (if (= res 2)
  866. X          '(var nan var-nan)
  867. X        a)))))
  868. )
  869. X
  870. (defun calcFunc-min (&optional a &rest b)
  871. X  (if (not a)
  872. X      '(var inf var-inf)
  873. X    (if (not (or (Math-anglep a) (eq (car a) 'date)
  874. X         (and (eq (car a) 'intv) (math-intv-constp a))
  875. X         (math-infinitep a)))
  876. X    (math-reject-arg a 'anglep))
  877. X    (math-min-list a b))
  878. )
  879. X
  880. (defun math-min-list (a b)
  881. X  (if b
  882. X      (if (or (Math-anglep (car b)) (eq (car b) 'date)
  883. X          (and (eq (car (car b)) 'intv) (math-intv-constp (car b)))
  884. X          (math-infinitep (car b)))
  885. X      (math-min-list (math-min a (car b)) (cdr b))
  886. X    (math-reject-arg (car b) 'anglep))
  887. X    a)
  888. )
  889. X
  890. ;;; Compute the maximum of two real numbers.  [R R R] [Public]
  891. (defun math-max (a b)
  892. X  (if (or (and (consp a) (eq (car a) 'intv))
  893. X      (and (consp b) (eq (car b) 'intv)))
  894. X      (math-neg (math-min (math-neg a) (math-neg b)))
  895. X    (let ((res (math-compare a b)))
  896. X      (if (= res -1)
  897. X      b
  898. X    (if (= res 2)
  899. X          '(var nan var-nan)
  900. X      a))))
  901. )
  902. X
  903. (defun calcFunc-max (&optional a &rest b)
  904. X  (if (not a)
  905. X      '(neg (var inf var-inf))
  906. X    (if (not (or (Math-anglep a) (eq (car a) 'date)
  907. X         (and (eq (car a) 'intv) (math-intv-constp a))
  908. X         (math-infinitep a)))
  909. X    (math-reject-arg a 'anglep))
  910. X    (math-max-list a b))
  911. )
  912. X
  913. (defun math-max-list (a b)
  914. X  (if b
  915. X      (if (or (Math-anglep (car b)) (eq (car b) 'date)
  916. X          (and (eq (car (car b)) 'intv) (math-intv-constp (car b)))
  917. X          (math-infinitep (car b)))
  918. X      (math-max-list (math-max a (car b)) (cdr b))
  919. X    (math-reject-arg (car b) 'anglep))
  920. X    a)
  921. )
  922. X
  923. X
  924. ;;; Compute the absolute value of A.  [O O; r r] [Public]
  925. (defun math-abs (a)
  926. X  (cond ((Math-negp a)
  927. X     (math-neg a))
  928. X    ((Math-anglep a)
  929. X     a)
  930. X    ((eq (car a) 'cplx)
  931. X     (math-hypot (nth 1 a) (nth 2 a)))
  932. X    ((eq (car a) 'polar)
  933. X     (nth 1 a))
  934. X    ((eq (car a) 'vec)
  935. X     (if (cdr (cdr (cdr a)))
  936. X         (math-sqrt (calcFunc-abssqr a))
  937. X       (if (cdr (cdr a))
  938. X           (math-hypot (nth 1 a) (nth 2 a))
  939. X         (if (cdr a)
  940. X         (math-abs (nth 1 a))
  941. X           a))))
  942. X    ((eq (car a) 'sdev)
  943. X     (list 'sdev (math-abs (nth 1 a)) (nth 2 a)))
  944. X    ((and (eq (car a) 'intv) (math-intv-constp a))
  945. X     (if (Math-posp a)
  946. X         a
  947. X       (let* ((nlo (math-neg (nth 2 a)))
  948. X          (res (math-compare nlo (nth 3 a))))
  949. X         (cond ((= res 1)
  950. X            (math-make-intv (if (memq (nth 1 a) '(0 1)) 2 3) 0 nlo))
  951. X           ((= res 0)
  952. X            (math-make-intv (if (eq (nth 1 a) 0) 2 3) 0 nlo))
  953. X           (t
  954. X            (math-make-intv (if (memq (nth 1 a) '(0 2)) 2 3)
  955. X                    0 (nth 3 a)))))))
  956. X    ((math-looks-negp a)
  957. X     (list 'calcFunc-abs (math-neg a)))
  958. X    ((let ((signs (math-possible-signs a)))
  959. X       (or (and (memq signs '(2 4 6)) a)
  960. X           (and (memq signs '(1 3)) (math-neg a)))))
  961. X    ((let ((inf (math-infinitep a)))
  962. X       (and inf
  963. X        (if (equal inf '(var nan var-nan))
  964. X            inf
  965. X          '(var inf var-inf)))))
  966. X    (t (calc-record-why 'numvecp a)
  967. X       (list 'calcFunc-abs a)))
  968. )
  969. (fset 'calcFunc-abs (symbol-function 'math-abs))
  970. X
  971. X
  972. (defun math-float-fancy (a)
  973. X  (cond ((eq (car a) 'intv)
  974. X     (cons (car a) (cons (nth 1 a) (mapcar 'math-float (nthcdr 2 a)))))
  975. X    ((and (memq (car a) '(* /))
  976. X          (math-numberp (nth 1 a)))
  977. X     (list (car a) (math-float (nth 1 a))
  978. X           (list 'calcFunc-float (nth 2 a))))
  979. X    ((and (eq (car a) '/)
  980. X          (eq (car (nth 1 a)) '*)
  981. X          (math-numberp (nth 1 (nth 1 a))))
  982. X     (list '* (math-float (nth 1 (nth 1 a)))
  983. X           (list 'calcFunc-float (list '/ (nth 2 (nth 1 a)) (nth 2 a)))))
  984. X    ((math-infinitep a) a)
  985. X    ((eq (car a) 'calcFunc-float) a)
  986. X    ((let ((func (assq (car a) '((calcFunc-floor  . calcFunc-ffloor)
  987. X                     (calcFunc-ceil   . calcFunc-fceil)
  988. X                     (calcFunc-trunc  . calcFunc-ftrunc)
  989. X                     (calcFunc-round  . calcFunc-fround)
  990. X                     (calcFunc-rounde . calcFunc-frounde)
  991. X                     (calcFunc-roundu . calcFunc-froundu)))))
  992. X       (and func (cons (cdr func) (cdr a)))))
  993. X    (t (math-reject-arg a 'objectp)))
  994. )
  995. (fset 'calcFunc-float (symbol-function 'math-float))
  996. X
  997. X
  998. (defun math-trunc-fancy (a)
  999. X  (cond ((eq (car a) 'frac) (math-quotient (nth 1 a) (nth 2 a)))
  1000. X    ((eq (car a) 'cplx) (math-trunc (nth 1 a)))
  1001. X    ((eq (car a) 'polar) (math-trunc (math-complex a)))
  1002. X    ((eq (car a) 'hms) (list 'hms (nth 1 a) 0 0))
  1003. X    ((eq (car a) 'date) (list 'date (math-trunc (nth 1 a))))
  1004. X    ((eq (car a) 'mod)
  1005. X     (if (math-messy-integerp (nth 2 a))
  1006. X         (math-trunc (math-make-mod (nth 1 a) (math-trunc (nth 2 a))))
  1007. X       (math-make-mod (math-trunc (nth 1 a)) (nth 2 a))))
  1008. X    ((eq (car a) 'intv)
  1009. X     (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
  1010. X                     (memq (nth 1 a) '(0 1)))
  1011. X                0 2)
  1012. X                (if (and (equal (nth 3 a) '(var inf var-inf))
  1013. X                     (memq (nth 1 a) '(0 2)))
  1014. X                0 1))
  1015. X             (if (and (Math-negp (nth 2 a))
  1016. X                  (Math-num-integerp (nth 2 a))
  1017. X                  (memq (nth 1 a) '(0 1)))
  1018. X                 (math-add (math-trunc (nth 2 a)) 1)
  1019. X               (math-trunc (nth 2 a)))
  1020. X             (if (and (Math-posp (nth 3 a))
  1021. X                  (Math-num-integerp (nth 3 a))
  1022. X                  (memq (nth 1 a) '(0 2)))
  1023. X                 (math-add (math-trunc (nth 3 a)) -1)
  1024. X               (math-trunc (nth 3 a)))))
  1025. X    ((math-provably-integerp a) a)
  1026. X    ((Math-vectorp a)
  1027. X     (math-map-vec (function (lambda (x) (math-trunc x prec))) a))
  1028. X    ((math-infinitep a)
  1029. X     (if (or (math-posp a) (math-negp a))
  1030. X         a
  1031. X       '(var nan var-nan)))
  1032. X    ((math-to-integer a))
  1033. X    (t (math-reject-arg a 'numberp)))
  1034. )
  1035. X
  1036. (defun math-trunc-special (a prec)
  1037. X  (if (Math-messy-integerp prec)
  1038. X      (setq prec (math-trunc prec)))
  1039. X  (or (integerp prec)
  1040. X      (math-reject-arg prec 'fixnump))
  1041. X  (if (and (<= prec 0)
  1042. X       (math-provably-integerp a))
  1043. X      a
  1044. X    (calcFunc-scf (math-trunc (let ((calc-prefer-frac t))
  1045. X                (calcFunc-scf a prec)))
  1046. X          (- prec)))
  1047. )
  1048. X
  1049. (defun math-to-integer (a)
  1050. X  (let ((func (assq (car-safe a) '((calcFunc-ffloor  . calcFunc-floor)
  1051. X                   (calcFunc-fceil   . calcFunc-ceil)
  1052. X                   (calcFunc-ftrunc  . calcFunc-trunc)
  1053. X                   (calcFunc-fround  . calcFunc-round)
  1054. X                   (calcFunc-frounde . calcFunc-rounde)
  1055. X                   (calcFunc-froundu . calcFunc-roundu)))))
  1056. X    (and func (= (length a) 2)
  1057. X     (cons (cdr func) (cdr a))))
  1058. )
  1059. X
  1060. (defun calcFunc-ftrunc (a &optional prec)
  1061. X  (if (and (Math-messy-integerp a)
  1062. X       (or (not prec) (and (integerp prec)
  1063. X                   (<= prec 0))))
  1064. X      a
  1065. X    (math-float (math-trunc a prec)))
  1066. )
  1067. X
  1068. (defun math-floor-fancy (a)
  1069. X  (cond ((math-provably-integerp a) a)
  1070. X    ((eq (car a) 'hms)
  1071. X     (if (or (math-posp a)
  1072. X         (and (math-zerop (nth 2 a))
  1073. X              (math-zerop (nth 3 a))))
  1074. X         (math-trunc a)
  1075. X       (math-add (math-trunc a) -1)))
  1076. X    ((eq (car a) 'date) (list 'date (math-floor (nth 1 a))))
  1077. X    ((eq (car a) 'intv)
  1078. X     (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
  1079. X                     (memq (nth 1 a) '(0 1)))
  1080. X                0 2)
  1081. X                (if (and (equal (nth 3 a) '(var inf var-inf))
  1082. X                     (memq (nth 1 a) '(0 2)))
  1083. X                0 1))
  1084. X             (math-floor (nth 2 a))
  1085. X             (if (and (Math-num-integerp (nth 3 a))
  1086. X                  (memq (nth 1 a) '(0 2)))
  1087. X                 (math-add (math-floor (nth 3 a)) -1)
  1088. X               (math-floor (nth 3 a)))))
  1089. X    ((Math-vectorp a)
  1090. X     (math-map-vec (function (lambda (x) (math-floor x prec))) a))
  1091. X    ((math-infinitep a)
  1092. X     (if (or (math-posp a) (math-negp a))
  1093. X         a
  1094. X       '(var nan var-nan)))
  1095. X    ((math-to-integer a))
  1096. X    (t (math-reject-arg a 'anglep)))
  1097. )
  1098. X
  1099. (defun math-floor-special (a prec)
  1100. X  (if (Math-messy-integerp prec)
  1101. X      (setq prec (math-trunc prec)))
  1102. X  (or (integerp prec)
  1103. X      (math-reject-arg prec 'fixnump))
  1104. X  (if (and (<= prec 0)
  1105. X       (math-provably-integerp a))
  1106. X      a
  1107. X    (calcFunc-scf (math-floor (let ((calc-prefer-frac t))
  1108. X                (calcFunc-scf a prec)))
  1109. X          (- prec)))
  1110. )
  1111. X
  1112. (defun calcFunc-ffloor (a &optional prec)
  1113. X  (if (and (Math-messy-integerp a)
  1114. X       (or (not prec) (and (integerp prec)
  1115. X                   (<= prec 0))))
  1116. X      a
  1117. X    (math-float (math-floor a prec)))
  1118. )
  1119. X
  1120. ;;; Coerce A to be an integer (by truncation toward plus infinity).  [I N]
  1121. (defun math-ceiling (a &optional prec)   ;  [Public]
  1122. X  (cond (prec
  1123. X     (if (Math-messy-integerp prec)
  1124. X         (setq prec (math-trunc prec)))
  1125. X     (or (integerp prec)
  1126. X         (math-reject-arg prec 'fixnump))
  1127. X     (if (and (<= prec 0)
  1128. X          (math-provably-integerp a))
  1129. X         a
  1130. X       (calcFunc-scf (math-ceiling (let ((calc-prefer-frac t))
  1131. X                     (calcFunc-scf a prec)))
  1132. X             (- prec))))
  1133. X    ((Math-integerp a) a)
  1134. X    ((Math-messy-integerp a) (math-trunc a))
  1135. X    ((Math-realp a)
  1136. X     (if (Math-posp a)
  1137. X         (math-add (math-trunc a) 1)
  1138. X       (math-trunc a)))
  1139. X    ((math-provably-integerp a) a)
  1140. X    ((eq (car a) 'hms)
  1141. X     (if (or (math-negp a)
  1142. X         (and (math-zerop (nth 2 a))
  1143. X              (math-zerop (nth 3 a))))
  1144. X         (math-trunc a)
  1145. X       (math-add (math-trunc a) 1)))
  1146. X    ((eq (car a) 'date) (list 'date (math-ceiling (nth 1 a))))
  1147. X    ((eq (car a) 'intv)
  1148. X     (math-make-intv (+ (if (and (equal (nth 2 a) '(neg (var inf var-inf)))
  1149. X                     (memq (nth 1 a) '(0 1)))
  1150. X                0 2)
  1151. X                (if (and (equal (nth 3 a) '(var inf var-inf))
  1152. X                     (memq (nth 1 a) '(0 2)))
  1153. X                0 1))
  1154. X             (if (and (Math-num-integerp (nth 2 a))
  1155. X                  (memq (nth 1 a) '(0 1)))
  1156. X                 (math-add (math-floor (nth 2 a)) 1)
  1157. X               (math-ceiling (nth 2 a)))
  1158. X             (math-ceiling (nth 3 a))))
  1159. X    ((Math-vectorp a)
  1160. X     (math-map-vec (function (lambda (x) (math-ceiling x prec))) a))
  1161. X    ((math-infinitep a)
  1162. X     (if (or (math-posp a) (math-negp a))
  1163. X         a
  1164. X       '(var nan var-nan)))
  1165. X    ((math-to-integer a))
  1166. X    (t (math-reject-arg a 'anglep)))
  1167. )
  1168. (fset 'calcFunc-ceil (symbol-function 'math-ceiling))
  1169. X
  1170. (defun calcFunc-fceil (a &optional prec)
  1171. X  (if (and (Math-messy-integerp a)
  1172. X       (or (not prec) (and (integerp prec)
  1173. X                   (<= prec 0))))
  1174. X      a
  1175. X    (math-float (math-ceiling a prec)))
  1176. )
  1177. X
  1178. (setq math-rounding-mode nil)
  1179. X
  1180. ;;; Coerce A to be an integer (by rounding to nearest integer).  [I N] [Public]
  1181. (defun math-round (a &optional prec)
  1182. X  (cond (prec
  1183. X     (if (Math-messy-integerp prec)
  1184. X         (setq prec (math-trunc prec)))
  1185. X     (or (integerp prec)
  1186. X         (math-reject-arg prec 'fixnump))
  1187. X     (if (and (<= prec 0)
  1188. X          (math-provably-integerp a))
  1189. X         a
  1190. X       (calcFunc-scf (math-round (let ((calc-prefer-frac t))
  1191. X                       (calcFunc-scf a prec)))
  1192. X             (- prec))))
  1193. X    ((Math-anglep a)
  1194. X     (if (Math-num-integerp a)
  1195. X         (math-trunc a)
  1196. X       (if (and (Math-negp a) (not (eq math-rounding-mode 'up)))
  1197. X           (math-neg (math-round (math-neg a)))
  1198. X         (setq a (let ((calc-angle-mode 'deg))   ; in case of HMS forms
  1199. X               (math-add a (if (Math-ratp a)
  1200. X                       '(frac 1 2)
  1201. X                     '(float 5 -1)))))
  1202. X         (if (and (Math-num-integerp a) (eq math-rounding-mode 'even))
  1203. X         (progn
  1204. X           (setq a (math-floor a))
  1205. X           (or (math-evenp a)
  1206. X               (setq a (math-sub a 1)))
  1207. X           a)
  1208. X           (math-floor a)))))
  1209. X    ((math-provably-integerp a) a)
  1210. X    ((eq (car a) 'date) (list 'date (math-round (nth 1 a))))
  1211. X    ((eq (car a) 'intv)
  1212. X     (math-floor (math-add a '(frac 1 2))))
  1213. X    ((Math-vectorp a)
  1214. X     (math-map-vec (function (lambda (x) (math-round x prec))) a))
  1215. X    ((math-infinitep a)
  1216. X     (if (or (math-posp a) (math-negp a))
  1217. X         a
  1218. X       '(var nan var-nan)))
  1219. X    ((math-to-integer a))
  1220. X    (t (math-reject-arg a 'anglep)))
  1221. )
  1222. (fset 'calcFunc-round (symbol-function 'math-round))
  1223. X
  1224. (defun calcFunc-rounde (a &optional prec)
  1225. X  (let ((math-rounding-mode 'even))
  1226. X    (math-round a prec))
  1227. )
  1228. X
  1229. (defun calcFunc-roundu (a &optional prec)
  1230. X  (let ((math-rounding-mode 'up))
  1231. X    (math-round a prec))
  1232. )
  1233. X
  1234. (defun calcFunc-fround (a &optional prec)
  1235. X  (if (and (Math-messy-integerp a)
  1236. X       (or (not prec) (and (integerp prec)
  1237. X                   (<= prec 0))))
  1238. X      a
  1239. X    (math-float (math-round a prec)))
  1240. )
  1241. X
  1242. (defun calcFunc-frounde (a &optional prec)
  1243. X  (let ((math-rounding-mode 'even))
  1244. X    (calcFunc-fround a prec))
  1245. )
  1246. X
  1247. (defun calcFunc-froundu (a &optional prec)
  1248. X  (let ((math-rounding-mode 'up))
  1249. X    (calcFunc-fround a prec))
  1250. )
  1251. X
  1252. X
  1253. ;;; Pull floating-point values apart into mantissa and exponent.
  1254. (defun calcFunc-mant (x)
  1255. X  (if (Math-realp x)
  1256. X      (if (or (Math-ratp x)
  1257. X          (eq (nth 1 x) 0))
  1258. X      x
  1259. X    (list 'float (nth 1 x) (- 1 (math-numdigs (nth 1 x)))))
  1260. X    (calc-record-why 'realp x)
  1261. X    (list 'calcFunc-mant x))
  1262. )
  1263. X
  1264. (defun calcFunc-xpon (x)
  1265. X  (if (Math-realp x)
  1266. X      (if (or (Math-ratp x)
  1267. X          (eq (nth 1 x) 0))
  1268. X      0
  1269. X    (math-normalize (+ (nth 2 x) (1- (math-numdigs (nth 1 x))))))
  1270. X    (calc-record-why 'realp x)
  1271. X    (list 'calcFunc-xpon x))
  1272. )
  1273. X
  1274. (defun calcFunc-scf (x n)
  1275. X  (if (integerp n)
  1276. X      (cond ((eq n 0)
  1277. X         x)
  1278. X        ((Math-integerp x)
  1279. X         (if (> n 0)
  1280. X         (math-scale-int x n)
  1281. X           (math-div x (math-scale-int 1 (- n)))))
  1282. X        ((eq (car x) 'frac)
  1283. X         (if (> n 0)
  1284. X         (math-make-frac (math-scale-int (nth 1 x) n) (nth 2 x))
  1285. X           (math-make-frac (nth 1 x) (math-scale-int (nth 2 x) (- n)))))
  1286. X        ((eq (car x) 'float)
  1287. X         (math-make-float (nth 1 x) (+ (nth 2 x) n)))
  1288. X        ((memq (car x) '(cplx sdev))
  1289. X         (math-normalize
  1290. X          (list (car x)
  1291. X            (calcFunc-scf (nth 1 x) n)
  1292. X            (calcFunc-scf (nth 2 x) n))))
  1293. X        ((memq (car x) '(polar mod))
  1294. X         (math-normalize
  1295. X          (list (car x)
  1296. X            (calcFunc-scf (nth 1 x) n)
  1297. X            (nth 2 x))))
  1298. X        ((eq (car x) 'intv)
  1299. X         (math-normalize
  1300. X          (list (car x)
  1301. X            (nth 1 x)
  1302. X            (calcFunc-scf (nth 2 x) n)
  1303. X            (calcFunc-scf (nth 3 x) n))))
  1304. X        ((eq (car x) 'vec)
  1305. X         (math-map-vec (function (lambda (x) (calcFunc-scf x n))) x))
  1306. X        ((math-infinitep x)
  1307. X         x)
  1308. X        (t
  1309. X         (calc-record-why 'realp x)
  1310. X         (list 'calcFunc-scf x n)))
  1311. X    (if (math-messy-integerp n)
  1312. X    (if (< (nth 2 n) 10)
  1313. X        (calcFunc-scf x (math-trunc n))
  1314. X      (math-overflow n))
  1315. X      (if (math-integerp n)
  1316. X      (math-overflow n)
  1317. X    (calc-record-why 'integerp n)
  1318. X    (list 'calcFunc-scf x n))))
  1319. )
  1320. X
  1321. X
  1322. (defun calcFunc-incr (x &optional step relative-to)
  1323. X  (or step (setq step 1))
  1324. X  (cond ((not (Math-integerp step))
  1325. X     (math-reject-arg step 'integerp))
  1326. X    ((Math-integerp x)
  1327. X     (math-add x step))
  1328. X    ((eq (car x) 'float)
  1329. X     (if (and (math-zerop x)
  1330. X          (eq (car-safe relative-to) 'float))
  1331. X         (math-mul step
  1332. X               (calcFunc-scf relative-to (- 1 calc-internal-prec)))
  1333. X       (math-add-float x (math-make-float
  1334. X                  step
  1335. X                  (+ (nth 2 x)
  1336. X                 (- (math-numdigs (nth 1 x))
  1337. X                    calc-internal-prec))))))
  1338. X    ((eq (car x) 'date)
  1339. X     (if (Math-integerp (nth 1 x))
  1340. X         (math-add x step)
  1341. X       (math-add x (list 'hms 0 0 step))))
  1342. X    (t
  1343. X     (math-reject-arg x 'realp)))
  1344. )
  1345. X
  1346. (defun calcFunc-decr (x &optional step relative-to)
  1347. X  (calcFunc-incr x (math-neg (or step 1)) relative-to)
  1348. )
  1349. X
  1350. X
  1351. (defun calcFunc-percent (x)
  1352. X  (if (math-objectp x)
  1353. X      (math-mul x '(float 1 -2))
  1354. X    (list 'calcFunc-percent x))
  1355. )
  1356. X
  1357. X
  1358. X
  1359. ;;; Compute the absolute value squared of A.  [F N] [Public]
  1360. (defun calcFunc-abssqr (a)
  1361. X  (cond ((Math-realp a)
  1362. X     (math-mul a a))
  1363. X    ((eq (car a) 'cplx)
  1364. X     (math-add (math-sqr (nth 1 a))
  1365. X           (math-sqr (nth 2 a))))
  1366. X    ((eq (car a) 'polar)
  1367. X     (math-sqr (nth 1 a)))
  1368. X    ((and (memq (car a) '(sdev intv)) (math-constp a))
  1369. X     (math-sqr (math-abs a)))
  1370. X    ((eq (car a) 'vec)
  1371. X     (math-reduce-vec 'math-add (math-map-vec 'calcFunc-abssqr a)))
  1372. X    ((math-known-realp a)
  1373. X     (math-pow a 2))
  1374. X    ((let ((inf (math-infinitep a)))
  1375. X       (and inf
  1376. X        (math-mul (calcFunc-abssqr (math-infinite-dir a inf)) inf))))
  1377. X    (t (calc-record-why 'numvecp a)
  1378. X       (list 'calcFunc-abssqr a)))
  1379. )
  1380. (defun math-sqr (a)
  1381. X  (math-mul a a)
  1382. )
  1383. X
  1384. X
  1385. ;;;; Number theory.
  1386. X
  1387. (defun calcFunc-idiv (a b)   ; [I I I] [Public]
  1388. X  (cond ((and (Math-natnump a) (Math-natnump b) (not (eq b 0)))
  1389. X     (math-quotient a b))
  1390. X    ((Math-realp a)
  1391. X     (if (Math-realp b)
  1392. X         (let ((calc-prefer-frac t))
  1393. X           (math-floor (math-div a b)))
  1394. X       (math-reject-arg b 'realp)))
  1395. X    ((eq (car-safe a) 'hms)
  1396. X     (if (eq (car-safe b) 'hms)
  1397. X         (let ((calc-prefer-frac t))
  1398. X           (math-floor (math-div a b)))
  1399. X       (math-reject-arg b 'hmsp)))
  1400. X    ((and (or (eq (car-safe a) 'intv) (Math-realp a))
  1401. X          (or (eq (car-safe b) 'intv) (Math-realp b)))
  1402. X     (math-floor (math-div a b)))
  1403. X    ((or (math-infinitep a)
  1404. X         (math-infinitep b))
  1405. X     (math-div a b))
  1406. X    (t (math-reject-arg a 'anglep)))
  1407. )
  1408. X
  1409. X
  1410. ;;; Combine two terms being added, if possible.
  1411. (defun math-combine-sum (a b nega negb scalar-okay)
  1412. X  (if (and scalar-okay (Math-objvecp a) (Math-objvecp b))
  1413. X      (math-add-or-sub a b nega negb)
  1414. X    (let ((amult 1) (bmult 1))
  1415. X      (and (consp a)
  1416. X       (cond ((and (eq (car a) '*)
  1417. X               (Math-objectp (nth 1 a)))
  1418. X          (setq amult (nth 1 a)
  1419. X            a (nth 2 a)))
  1420. X         ((and (eq (car a) '/)
  1421. X               (Math-objectp (nth 2 a)))
  1422. X          (setq amult (if (Math-integerp (nth 2 a))
  1423. X                  (list 'frac 1 (nth 2 a))
  1424. X                (math-div 1 (nth 2 a)))
  1425. X            a (nth 1 a)))
  1426. X         ((eq (car a) 'neg)
  1427. X          (setq amult -1
  1428. X            a (nth 1 a)))))
  1429. X      (and (consp b)
  1430. X       (cond ((and (eq (car b) '*)
  1431. X               (Math-objectp (nth 1 b)))
  1432. X          (setq bmult (nth 1 b)
  1433. X            b (nth 2 b)))
  1434. X         ((and (eq (car b) '/)
  1435. X               (Math-objectp (nth 2 b)))
  1436. X          (setq bmult (if (Math-integerp (nth 2 b))
  1437. X                  (list 'frac 1 (nth 2 b))
  1438. X                (math-div 1 (nth 2 b)))
  1439. X            b (nth 1 b)))
  1440. X         ((eq (car b) 'neg)
  1441. X          (setq bmult -1
  1442. X            b (nth 1 b)))))
  1443. X      (and (if math-simplifying
  1444. X           (Math-equal a b)
  1445. X         (equal a b))
  1446. X       (progn
  1447. X         (if nega (setq amult (math-neg amult)))
  1448. X         (if negb (setq bmult (math-neg bmult)))
  1449. X         (setq amult (math-add amult bmult))
  1450. X         (math-mul amult a)))))
  1451. )
  1452. X
  1453. (defun math-add-or-sub (a b aneg bneg)
  1454. X  (if aneg (setq a (math-neg a)))
  1455. X  (if bneg (setq b (math-neg b)))
  1456. X  (if (or (Math-vectorp a) (Math-vectorp b))
  1457. X      (math-normalize (list '+ a b))
  1458. X    (math-add a b))
  1459. )
  1460. X
  1461. ;;; The following is expanded out four ways for speed.
  1462. (defun math-combine-prod (a b inva invb scalar-okay)
  1463. X  (cond
  1464. X   ((or (and inva (Math-zerop a))
  1465. X    (and invb (Math-zerop b)))
  1466. X    nil)
  1467. X   ((and scalar-okay (Math-objvecp a) (Math-objvecp b))
  1468. X    (setq a (math-mul-or-div a b inva invb))
  1469. X    (and (Math-objvecp a)
  1470. X     a))
  1471. X   ((and (eq (car-safe a) '^)
  1472. X     inva
  1473. X     (math-looks-negp (nth 2 a)))
  1474. X    (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b))
  1475. X   ((and (eq (car-safe b) '^)
  1476. X     invb
  1477. X     (math-looks-negp (nth 2 b)))
  1478. X    (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b)))))
  1479. X   (t (let ((apow 1) (bpow 1))
  1480. X    (and (consp a)
  1481. X         (cond ((and (eq (car a) '^)
  1482. X             (or math-simplifying
  1483. X                 (Math-numberp (nth 2 a))))
  1484. X            (setq apow (nth 2 a)
  1485. X              a (nth 1 a)))
  1486. X           ((eq (car a) 'calcFunc-sqrt)
  1487. X            (setq apow '(frac 1 2)
  1488. X              a (nth 1 a)))
  1489. X           ((and (eq (car a) 'calcFunc-exp)
  1490. X             (or math-simplifying
  1491. X                 (Math-numberp (nth 1 a))))
  1492. X            (setq apow (nth 1 a)
  1493. X              a math-combine-prod-e))))
  1494. X    (and (consp a) (eq (car a) 'frac)
  1495. X         (Math-lessp (nth 1 a) (nth 2 a))
  1496. X         (setq a (math-div 1 a) apow (math-neg apow)))
  1497. X    (and (consp b)
  1498. X         (cond ((and (eq (car b) '^)
  1499. X             (or math-simplifying
  1500. X                 (Math-numberp (nth 2 b))))
  1501. X            (setq bpow (nth 2 b)
  1502. X              b (nth 1 b)))
  1503. X           ((eq (car b) 'calcFunc-sqrt)
  1504. X            (setq bpow '(frac 1 2)
  1505. X              b (nth 1 b)))
  1506. X           ((and (eq (car b) 'calcFunc-exp)
  1507. X             (or math-simplifying
  1508. X                 (Math-numberp (nth 1 b))))
  1509. X            (setq bpow (nth 1 b)
  1510. X              b math-combine-prod-e))))
  1511. X    (and (consp b) (eq (car b) 'frac)
  1512. X         (Math-lessp (nth 1 b) (nth 2 b))
  1513. X         (setq b (math-div 1 b) bpow (math-neg bpow)))
  1514. X    (if inva (setq apow (math-neg apow)))
  1515. X    (if invb (setq bpow (math-neg bpow)))
  1516. X    (or (and (if math-simplifying
  1517. X             (math-commutative-equal a b)
  1518. X           (equal a b))
  1519. X         (let ((sumpow (math-add apow bpow)))
  1520. X           (and (or (not (Math-integerp a))
  1521. X                (Math-zerop sumpow)
  1522. X                (eq (eq (car-safe apow) 'frac)
  1523. X                (eq (car-safe bpow) 'frac)))
  1524. X            (progn
  1525. X              (and (math-looks-negp sumpow)
  1526. X                   (Math-ratp a) (Math-posp a)
  1527. X                   (setq a (math-div 1 a)
  1528. X                     sumpow (math-neg sumpow)))
  1529. X              (cond ((equal sumpow '(frac 1 2))
  1530. X                 (list 'calcFunc-sqrt a))
  1531. X                ((equal sumpow '(frac -1 2))
  1532. X                 (math-div 1 (list 'calcFunc-sqrt a)))
  1533. X                ((and (eq a math-combine-prod-e)
  1534. X                      (eq a b))
  1535. X                 (list 'calcFunc-exp sumpow))
  1536. X                (t
  1537. X                 (condition-case err
  1538. X                     (math-pow a sumpow)
  1539. X                   (inexact-result (list '^ a sumpow)))))))))
  1540. X        (and math-simplifying-units
  1541. X         math-combining-units
  1542. X         (let* ((ua (math-check-unit-name a))
  1543. X            ub)
  1544. X           (and ua
  1545. X            (eq ua (setq ub (math-check-unit-name b)))
  1546. X            (progn
  1547. X              (setq ua (if (eq (nth 1 a) (car ua))
  1548. X                       1
  1549. X                     (nth 1 (assq (aref (symbol-name (nth 1 a))
  1550. X                            0)
  1551. X                          math-unit-prefixes)))
  1552. X                ub (if (eq (nth 1 b) (car ub))
  1553. X                       1
  1554. X                     (nth 1 (assq (aref (symbol-name (nth 1 b))
  1555. X                            0)
  1556. X                          math-unit-prefixes))))
  1557. X              (if (Math-lessp ua ub)
  1558. X                  (let (temp)
  1559. X                (setq temp a a b b temp
  1560. X                      temp ua ua ub ub temp
  1561. X                      temp apow apow bpow bpow temp)))
  1562. X              (math-mul (math-pow (math-div ua ub) apow)
  1563. X                    (math-pow b (math-add apow bpow)))))))
  1564. X        (and (equal apow bpow)
  1565. X         (Math-natnump a) (Math-natnump b)
  1566. X         (cond ((equal apow '(frac 1 2))
  1567. X            (list 'calcFunc-sqrt (math-mul a b)))
  1568. X               ((equal apow '(frac -1 2))
  1569. X            (math-div 1 (list 'calcFunc-sqrt (math-mul a b))))
  1570. X               (t
  1571. X            (setq a (math-mul a b))
  1572. X            (condition-case err
  1573. X                (math-pow a apow)
  1574. X              (inexact-result (list '^ a apow))))))))))
  1575. )
  1576. (setq math-combine-prod-e '(var e var-e))
  1577. X
  1578. (defun math-mul-or-div (a b ainv binv)
  1579. X  (if (or (Math-vectorp a) (Math-vectorp b))
  1580. X      (math-normalize
  1581. X       (if ainv
  1582. X       (if binv
  1583. X           (list '/ (math-div 1 a) b)
  1584. X         (list '/ b a))
  1585. X     (if binv
  1586. X         (list '/ a b)
  1587. X       (list '* a b))))
  1588. X    (if ainv
  1589. X    (if binv
  1590. X        (math-div (math-div 1 a) b)
  1591. X      (math-div b a))
  1592. X      (if binv
  1593. X      (math-div a b)
  1594. X    (math-mul a b))))
  1595. )
  1596. X
  1597. (defun math-commutative-equal (a b)
  1598. X  (if (memq (car-safe a) '(+ -))
  1599. X      (and (memq (car-safe b) '(+ -))
  1600. X       (let ((bterms nil) aterms p)
  1601. X         (math-commutative-collect b nil)
  1602. X         (setq aterms bterms bterms nil)
  1603. X         (math-commutative-collect a nil)
  1604. X         (and (= (length aterms) (length bterms))
  1605. X          (progn
  1606. X            (while (and aterms
  1607. X                (progn
  1608. X                  (setq p bterms)
  1609. X                  (while (and p (not (equal (car aterms)
  1610. X                                (car p))))
  1611. X                    (setq p (cdr p)))
  1612. X                  p))
  1613. X              (setq bterms (delq (car p) bterms)
  1614. X                aterms (cdr aterms)))
  1615. X            (not aterms)))))
  1616. X    (equal a b))
  1617. )
  1618. X
  1619. (defun math-commutative-collect (b neg)
  1620. X  (if (eq (car-safe b) '+)
  1621. X      (progn
  1622. X    (math-commutative-collect (nth 1 b) neg)
  1623. X    (math-commutative-collect (nth 2 b) neg))
  1624. X    (if (eq (car-safe b) '-)
  1625. X    (progn
  1626. X      (math-commutative-collect (nth 1 b) neg)
  1627. X      (math-commutative-collect (nth 2 b) (not neg)))
  1628. X      (setq bterms (cons (if neg (math-neg b) b) bterms))))
  1629. )
  1630. X
  1631. X
  1632. SHAR_EOF
  1633. echo 'File calc-arith.el is complete' &&
  1634. chmod 0644 calc-arith.el ||
  1635. echo 'restore of calc-arith.el failed'
  1636. Wc_c="`wc -c < 'calc-arith.el'`"
  1637. test 86526 -eq "$Wc_c" ||
  1638.     echo 'calc-arith.el: original size 86526, current size' "$Wc_c"
  1639. rm -f _shar_wnt_.tmp
  1640. fi
  1641. # ============= calc-bin.el ==============
  1642. if test -f 'calc-bin.el' -a X"$1" != X"-c"; then
  1643.     echo 'x - skipping calc-bin.el (File already exists)'
  1644.     rm -f _shar_wnt_.tmp
  1645. else
  1646. > _shar_wnt_.tmp
  1647. echo 'x - extracting calc-bin.el (Text)'
  1648. sed 's/^X//' << 'SHAR_EOF' > 'calc-bin.el' &&
  1649. ;; Calculator for GNU Emacs, part II [calc-bin.el]
  1650. ;; Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  1651. ;; Written by Dave Gillespie, daveg@csvax.cs.caltech.edu.
  1652. X
  1653. ;; This file is part of GNU Emacs.
  1654. X
  1655. ;; GNU Emacs is distributed in the hope that it will be useful,
  1656. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  1657. ;; accepts responsibility to anyone for the consequences of using it
  1658. ;; or for whether it serves any particular purpose or works at all,
  1659. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  1660. ;; License for full details.
  1661. X
  1662. ;; Everyone is granted permission to copy, modify and redistribute
  1663. ;; GNU Emacs, but only under the conditions described in the
  1664. ;; GNU Emacs General Public License.   A copy of this license is
  1665. ;; supposed to have been given to you along with GNU Emacs so you
  1666. ;; can know your rights and responsibilities.  It should be in a
  1667. ;; file named COPYING.  Among other things, the copyright notice
  1668. ;; and this notice must be preserved on all copies.
  1669. X
  1670. X
  1671. X
  1672. ;; This file is autoloaded from calc-ext.el.
  1673. (require 'calc-ext)
  1674. X
  1675. (require 'calc-macs)
  1676. X
  1677. (defun calc-Need-calc-bin () nil)
  1678. X
  1679. X
  1680. ;;; b-prefix binary commands.
  1681. X
  1682. (defun calc-and (n)
  1683. X  (interactive "P")
  1684. X  (calc-slow-wrapper
  1685. X   (calc-enter-result 2 "and"
  1686. X              (append '(calcFunc-and)
  1687. X                  (calc-top-list-n 2)
  1688. X                  (and n (list (prefix-numeric-value n))))))
  1689. )
  1690. X
  1691. (defun calc-or (n)
  1692. X  (interactive "P")
  1693. X  (calc-slow-wrapper
  1694. X   (calc-enter-result 2 "or"
  1695. X              (append '(calcFunc-or)
  1696. X                  (calc-top-list-n 2)
  1697. X                  (and n (list (prefix-numeric-value n))))))
  1698. )
  1699. X
  1700. (defun calc-xor (n)
  1701. X  (interactive "P")
  1702. X  (calc-slow-wrapper
  1703. X   (calc-enter-result 2 "xor"
  1704. X              (append '(calcFunc-xor)
  1705. X                  (calc-top-list-n 2)
  1706. X                  (and n (list (prefix-numeric-value n))))))
  1707. )
  1708. X
  1709. (defun calc-diff (n)
  1710. X  (interactive "P")
  1711. X  (calc-slow-wrapper
  1712. X   (calc-enter-result 2 "diff"
  1713. X              (append '(calcFunc-diff)
  1714. X                  (calc-top-list-n 2)
  1715. X                  (and n (list (prefix-numeric-value n))))))
  1716. )
  1717. X
  1718. (defun calc-not (n)
  1719. X  (interactive "P")
  1720. X  (calc-slow-wrapper
  1721. X   (calc-enter-result 1 "not"
  1722. X              (append '(calcFunc-not)
  1723. X                  (calc-top-list-n 1)
  1724. X                  (and n (list (prefix-numeric-value n))))))
  1725. )
  1726. X
  1727. (defun calc-lshift-binary (n)
  1728. X  (interactive "P")
  1729. X  (calc-slow-wrapper
  1730. X   (let ((hyp (if (calc-is-hyperbolic) 2 1)))
  1731. X     (calc-enter-result hyp "lsh"
  1732. X            (append '(calcFunc-lsh)
  1733. X                (calc-top-list-n hyp)
  1734. X                (and n (list (prefix-numeric-value n)))))))
  1735. )
  1736. X
  1737. (defun calc-rshift-binary (n)
  1738. X  (interactive "P")
  1739. X  (calc-slow-wrapper
  1740. X   (let ((hyp (if (calc-is-hyperbolic) 2 1)))
  1741. X     (calc-enter-result hyp "rsh"
  1742. X            (append '(calcFunc-rsh)
  1743. X                (calc-top-list-n hyp)
  1744. X                (and n (list (prefix-numeric-value n)))))))
  1745. )
  1746. X
  1747. (defun calc-lshift-arith (n)
  1748. X  (interactive "P")
  1749. X  (calc-slow-wrapper
  1750. X   (let ((hyp (if (calc-is-hyperbolic) 2 1)))
  1751. X     (calc-enter-result hyp "ash"
  1752. X            (append '(calcFunc-ash)
  1753. X                (calc-top-list-n hyp)
  1754. X                (and n (list (prefix-numeric-value n)))))))
  1755. )
  1756. X
  1757. (defun calc-rshift-arith (n)
  1758. X  (interactive "P")
  1759. X  (calc-slow-wrapper
  1760. X   (let ((hyp (if (calc-is-hyperbolic) 2 1)))
  1761. X     (calc-enter-result hyp "rash"
  1762. X            (append '(calcFunc-rash)
  1763. X                (calc-top-list-n hyp)
  1764. X                (and n (list (prefix-numeric-value n)))))))
  1765. )
  1766. X
  1767. (defun calc-rotate-binary (n)
  1768. X  (interactive "P")
  1769. X  (calc-slow-wrapper
  1770. X   (let ((hyp (if (calc-is-hyperbolic) 2 1)))
  1771. X     (calc-enter-result hyp "rot"
  1772. X            (append '(calcFunc-rot)
  1773. X                (calc-top-list-n hyp)
  1774. X                (and n (list (prefix-numeric-value n)))))))
  1775. )
  1776. X
  1777. (defun calc-clip (n)
  1778. X  (interactive "P")
  1779. X  (calc-slow-wrapper
  1780. X   (calc-enter-result 1 "clip"
  1781. X              (append '(calcFunc-clip)
  1782. X                  (calc-top-list-n 1)
  1783. X                  (and n (list (prefix-numeric-value n))))))
  1784. )
  1785. X
  1786. (defun calc-word-size (n)
  1787. X  (interactive "P")
  1788. X  (calc-wrapper
  1789. X   (or n (setq n (read-string (format "Binary word size: (default %d) "
  1790. X                      calc-word-size))))
  1791. X   (setq n (if (stringp n)
  1792. X           (if (equal n "")
  1793. X           calc-word-size
  1794. X         (if (string-match "\\`[-+]?[0-9]+\\'" n)
  1795. X             (string-to-int n)
  1796. X           (error "Expected an integer")))
  1797. X         (prefix-numeric-value n)))
  1798. X   (or (= n calc-word-size)
  1799. X       (if (> (math-abs n) 100)
  1800. X       (calc-change-mode 'calc-word-size n calc-leading-zeros)
  1801. X     (calc-change-mode '(calc-word-size calc-previous-modulo)
  1802. X               (list n (math-power-of-2 (math-abs n)))
  1803. X               calc-leading-zeros)))
  1804. X   (if (< n 0)
  1805. X       (message "Binary word size is %d bits (2's complement)." (- n))
  1806. X     (message "Binary word size is %d bits." n)))
  1807. )
  1808. X
  1809. X
  1810. X
  1811. X
  1812. X
  1813. ;;; d-prefix mode commands.
  1814. X
  1815. (defun calc-radix (n)
  1816. SHAR_EOF
  1817. true || echo 'restore of calc-bin.el failed'
  1818. fi
  1819. echo 'End of  part 9'
  1820. echo 'File calc-bin.el is continued in part 10'
  1821. echo 10 > _shar_seq_.tmp
  1822. exit 0
  1823. exit 0 # Just in case...
  1824. -- 
  1825. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1826. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1827. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1828. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1829.